home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Wood / disk-cache.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  20.4 KB  |  503 lines  |  [TEXT/CCL2]
  1. ;;;-*- Mode: Lisp; Package: WOOD -*-
  2.  
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;
  5. ;; disk-cache.lisp
  6. ;; Copyright © 1992 Apple Computer, Inc. All rights reserved.
  7. ;; Code to support a cached byte I/O stream.
  8. ;;
  9.  
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  11. ;;
  12. ;; Modification History
  13. ;;
  14. ;; ------------- 0.5
  15. ;; 07/09/92 bill Don't extend the file until flushing a page requires it.
  16. ;;               Keep a lock count, not just a bit.
  17. ;; 03/05/92 bill New file
  18. ;;
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;;
  22. ;; To do:
  23. ;;
  24. ;; without-interrupts in just the right places.
  25. ;; Add a journaling option.
  26. ;; Multi-user support.
  27. ;;
  28.  
  29. (defpackage :wood)
  30. (in-package :wood)
  31.  
  32. (export '(open-disk-cache close-disk-cache disk-cache-size
  33.           get-disk-page mark-page-modified extend-disk-cache))
  34.  
  35. ;;;;;;;;;;;;;
  36. ;;
  37. ;; (open-disk-cache filename &key shared-p page-size max-pages
  38. ;;                  if-exists if-does-not-exist)
  39. ;;
  40. ;; filename            string or pathname
  41. ;; shared-p            boolean. Open for shared I/O if specified and true.
  42. ;; page-size           default: 512
  43. ;; max-pages           default: 200
  44. ;; if-exists           nil, :error, :supersede, or :overwrite.
  45. ;;                     Default: :overwrite
  46. ;; if-does-not-exist   Same as for OPEN. default: :error. 
  47. ;;
  48. ;; returns one value, a DISK-CACHE structure
  49.  
  50. ;;;;;;;;;;;;;
  51. ;;
  52. ;; (close-disk-cache disk-cache)
  53. ;;
  54. ;; Flushes dirty pages and closes the stream for the given disk-cache.
  55.  
  56. ;;;;;;;;;;;;;
  57. ;;
  58. ;; (disk-cache-size disk-cache)
  59. ;;
  60. ;; Return the number of bytes in the file
  61.  
  62. ;;;;;;;;;;;;;
  63. ;;
  64. ;; (get-disk-page disk-cache address &optional modify-p)
  65. ;;
  66. ;; disk-cache    DISK-CACHE structure, as returned from OPEN-DISK-CACHE.
  67. ;; address       fixnum. the address from/to you wish to I/O
  68. ;; modify-p      boolean. True if you plan to write. Default: nil.
  69. ;;
  70. ;; returns four values:
  71. ;; 1) array   an array of type (array (signed-byte 8)) containing the byte
  72. ;;            at address
  73. ;; 2) offset  fixnum. The offset in the array for the byte at address.
  74. ;; 3) length  fixnum. The number of bytes of valid data in array at offset.
  75. ;;                    Will be (- page-size (mod address page-size))
  76. ;;                    unless the page is the last one or later.
  77. ;; 4) page   a disk-page structure that can be passed to mark-page-modified
  78.  
  79. ;;;;;;;;;;;;;
  80. ;;
  81. ;; (mark-page-modified disk-page)
  82. ;;
  83. ;; disk-page    DISK-PAGE structure as returned in the fourth value from
  84. ;;              GET-DISK-PAGE.
  85. ;;
  86. ;; Sometimes you don't know in advance whether you'll modify a page.
  87. ;;
  88. ;; Returns true if the page was not already marked as modified, NIL
  89. ;; otherwise.
  90.  
  91. ;;;;;;;;;;;;;
  92. ;;
  93. ;; (extend-disk-cache disk-cache new-size)
  94. ;;
  95. ;; new-size   the new size of the file in bytes.
  96. ;;            If smaller than the current size, this is a NOP.
  97.  
  98.  
  99. (defstruct (disk-cache (:print-function print-disk-cache))
  100.   stream                                ; a stream to a file
  101.   size                                  ; the length of the file
  102.   (page-size 512)                       ; size of a disk-page in bytes
  103.   (mask -512)                           ; address mask
  104.   page-count                            ; number of disk pages
  105.   max-pages                             ; user's maximum
  106.   page-hash                             ; page-address -> disk-page structure
  107.   pages                                 ; head of the disk-page chain
  108.   dirty-pages                           ; head of the dirty page chain
  109.   locked-pages                          ; head of locked pages chain
  110.   log                                   ; a LOG structure: see "recovery.lisp"
  111.   write-hook                            ; hook to call when a page is written to disk
  112.   file-eof                              ; current EOF on disk
  113.   )
  114.  
  115. (defun print-disk-cache (disk-cache stream level)
  116.   (declare (ignore level))
  117.   (print-unreadable-object (disk-cache stream :type t :identity t)
  118.     (prin1 (pathname (disk-cache-stream disk-cache)) stream)))
  119.           
  120. (defstruct (disk-page (:print-function print-disk-page))
  121.   disk-cache                            ; back pointer
  122.   stream                                ; the stream (did you guess?)
  123.   address                               ; file address of base of this page
  124.   (flags 0)                             ; bit 0 = dirty
  125.   (size 0)                              ; actual size (smaller for last page)
  126.   next                                  ; next disk-page in the chain
  127.   prev                                  ; previous disk-page in the chain
  128.   next-dirty                            ; next dirty page
  129.   prev-dirty                            ; previous dirty page
  130.   data                                  ; an (unsigned-byte 8) array
  131.   (lock-count 0))                       ; non-zero means locked that many times.
  132.  
  133. (defconstant $disk-page-flags_dirty-bit 0)
  134.  
  135. (defun disk-page-dirty (disk-page)
  136.   (logbitp $disk-page-flags_dirty-bit
  137.            (the fixnum (disk-page-flags disk-page))))
  138.  
  139. (defun (setf disk-page-dirty) (value disk-page)
  140.   (setf (disk-page-flags disk-page)
  141.         (if value
  142.           (ccl::bitset $disk-page-flags_dirty-bit (disk-page-flags disk-page))
  143.           (ccl::bitclr $disk-page-flags_dirty-bit (disk-page-flags disk-page))))
  144.   (not (null value)))
  145.  
  146. (defun disk-page-locked (disk-page)
  147.   (let ((count (disk-page-lock-count disk-page)))
  148.     (unless (eql 0 count)
  149.       count)))
  150.  
  151. (defun print-disk-page (disk-page stream level)
  152.   (declare (ignore level))
  153.   (print-unreadable-object (disk-page stream :type t :identity t)
  154.     (format stream "~s~@{ ~s~}"
  155.             (disk-page-address disk-page)
  156.             (disk-page-size disk-page)
  157.             (disk-page-dirty disk-page)
  158.             (pathname (disk-page-stream disk-page)))))
  159.  
  160. (defun cons-disk-page (disk-cache size)
  161.   (make-disk-page :disk-cache disk-cache
  162.                   :stream (disk-cache-stream disk-cache)
  163.                   :data (make-array size :element-type '(unsigned-byte 8))))
  164.  
  165. (defvar *open-disk-caches* nil)
  166.  
  167. (defun open-disk-cache (filename &key shared-p (page-size 512) (max-pages 200)
  168.                                  (if-exists :overwrite)
  169.                                  (if-does-not-exist :error)
  170.                                  (external-format :???? ef-p)
  171.                                  write-hook)
  172.   (let ((mask (lognot (1- (expt 2 (1- (integer-length page-size)))))))
  173.     (unless (eql page-size (logand page-size mask))
  174.       (error "page-size must be a power of 2"))
  175.     (if (probe-file filename)
  176.       (if (and ef-p (neq external-format (mac-file-type filename)))
  177.         (error "(mac-file-type ~s) was ~s, should be ~s"
  178.                filename (mac-file-type filename) external-format))
  179.       (setq ef-p t))
  180.     (let* ((ef (list :external-format external-format))
  181.            (stream (apply #'open
  182.                           filename
  183.                          :direction (if shared-p :shared :io)
  184.                          :if-exists if-exists
  185.                          :if-does-not-exist if-does-not-exist
  186.                          (if ef-p ef))))
  187.       (declare (dynamic-extent ef))
  188.       (when stream
  189.         (let* ((size (file-length stream))
  190.                (disk-cache (make-disk-cache :stream stream
  191.                                             :size size
  192.                                             :file-eof size
  193.                                             :page-size page-size
  194.                                             :mask mask
  195.                                             :max-pages max-pages
  196.                                             :write-hook write-hook)))
  197.           (multiple-value-bind (pages page-count)
  198.                                (make-linked-disk-pages 
  199.                                 disk-cache page-size max-pages (file-length stream))
  200.             (setf (disk-cache-pages disk-cache) pages
  201.                   (disk-cache-page-count disk-cache) page-count
  202.                   (disk-cache-page-hash disk-cache) (make-hash-table :size page-count)))
  203.           (push disk-cache *open-disk-caches*)
  204.           disk-cache)))))
  205.  
  206. (defun make-linked-disk-pages (disk-cache page-size page-count &optional file-length)
  207.   (when file-length
  208.     (setq page-count (max 1 (min page-count
  209.                                  (floor (+ file-length page-size -1)
  210.                                         page-size)))))
  211.   (let (page last-page)
  212.     (dotimes (i page-count)
  213.       (let ((new-page (cons-disk-page disk-cache page-size)))
  214.         (setf (disk-page-next new-page) page)
  215.         (if page
  216.           (setf (disk-page-prev page) new-page)
  217.           (setq last-page new-page))
  218.         (setq page new-page)))
  219.     (setf (disk-page-next last-page) page
  220.           (disk-page-prev page) last-page)
  221.     (values page page-count)))
  222.  
  223. (defun add-disk-pages (disk-cache count)
  224.   (let* ((old-first-page (disk-cache-pages disk-cache))
  225.          (new-first-page (make-linked-disk-pages
  226.                           disk-cache
  227.                           (disk-cache-page-size disk-cache)
  228.                           count)))
  229.     (when old-first-page
  230.       (let ((old-last-page (disk-page-prev old-first-page))
  231.             (new-last-page (disk-page-prev new-first-page)))
  232.         (setf (disk-page-next new-last-page) old-first-page
  233.               (disk-page-prev old-first-page) new-last-page
  234.               (disk-page-next old-last-page) new-first-page
  235.               (disk-page-prev new-first-page) old-last-page)))
  236.     (setf (disk-cache-pages disk-cache) new-first-page)
  237.     (incf (disk-cache-page-count disk-cache) count)))
  238.  
  239. (defun close-disk-cache (disk-cache)
  240.   (flush-disk-cache disk-cache)
  241.   (setq *open-disk-caches* (delq disk-cache *open-disk-caches* 1))
  242.   (close (disk-cache-stream disk-cache))
  243.   (setf (disk-cache-page-hash disk-cache) nil))
  244.  
  245. (defun flush-disk-cache (disk-cache)
  246.   (loop
  247.     (let* ((page (disk-cache-dirty-pages disk-cache)))
  248.       (unless page (return))
  249.       (flush-disk-page page)))
  250.   (finish-output (disk-cache-stream disk-cache)))
  251.  
  252. (defun read-disk-page (disk-page address)
  253.   (flush-disk-page disk-page)
  254.   (setf (disk-page-address disk-page) address)
  255.   (let* ((disk-cache (disk-page-disk-cache disk-page))
  256.          (size (disk-cache-size disk-cache))
  257.          (file-eof (disk-cache-file-eof disk-cache))
  258.          (page-size (min (disk-cache-page-size disk-cache) (- size address))))
  259.     (when (> file-eof address)
  260.       (stream-read-bytes (disk-page-stream disk-page)
  261.                          address
  262.                          (disk-page-data disk-page)
  263.                          0
  264.                          page-size))
  265.     (setf (disk-page-size disk-page) page-size)))
  266.  
  267. (defun flush-disk-page (disk-page)
  268.   (let* ((disk-cache (disk-page-disk-cache disk-page))
  269.          (write-hook (disk-cache-write-hook disk-cache)))
  270.     (when (and write-hook (disk-page-dirty disk-page))
  271.       (funcall write-hook disk-page))
  272.     (when (disk-page-dirty disk-page)   ; write-hook may have flushed this page
  273.       (let* ((address (disk-page-address disk-page))
  274.              (size (disk-page-size disk-page))
  275.              (end-of-page (+ address size))
  276.              (stream (disk-page-stream disk-page)))
  277.         (when (> end-of-page (disk-cache-file-eof disk-cache))
  278.           (set-minimum-file-length stream end-of-page)
  279.           (setf (disk-cache-file-eof disk-cache) end-of-page))
  280.         (stream-write-bytes stream
  281.                             address
  282.                             (disk-page-data disk-page)
  283.                             0
  284.                             size))
  285.       (let* ((next (disk-page-next-dirty disk-page))
  286.              (prev (disk-page-prev-dirty disk-page)))
  287.         (if (eq next disk-page)
  288.           (setf next nil)
  289.           (setf (disk-page-next-dirty prev) next
  290.                 (disk-page-prev-dirty next) prev))
  291.         (setf (disk-page-next-dirty disk-page) nil
  292.               (disk-page-prev-dirty disk-page) nil)
  293.         (when (eq disk-page (disk-cache-dirty-pages disk-cache))
  294.           (setf (disk-cache-dirty-pages disk-cache) next))))
  295.     (setf (disk-page-dirty disk-page) nil)))
  296.  
  297. ; This does least-recently-swapped for now.
  298. ; Could easily be modified to do least-recently-used, though
  299. ; that would slow it down a little.
  300. (defun get-disk-page (disk-cache address &optional modify-p)
  301.   (let* ((hash (disk-cache-page-hash disk-cache))
  302.          (base-address (logand address (disk-cache-mask disk-cache)))
  303.          (page (gethash base-address hash))
  304.          (offset (- address base-address))
  305.          size)
  306.     (block get-the-page
  307.       (if page
  308.         (setq size (disk-page-size page))
  309.         (let ((max-size (disk-cache-size disk-cache)))
  310.           (if (>= address max-size)
  311.             (if (> address max-size)
  312.               (error "~s > size of ~s" address disk-cache)
  313.               (when (eql address base-address)
  314.                 ; If the address is the beginning of a page, and the end of
  315.                 ; the file, return a pointer off the end of the last page.
  316.                 (setq base-address (logand (1- address) (disk-cache-mask disk-cache))
  317.                       offset (- address base-address)
  318.                       page (gethash base-address hash))
  319.                 (when page
  320.                   (setq size (disk-page-size page))
  321.                   (return-from get-the-page)))))
  322.           (setq page (disk-cache-pages disk-cache))
  323.           (remhash (disk-page-address page) hash)
  324.           ; Here's the least-recently-swapped part
  325.           (setf (disk-cache-pages disk-cache) (disk-page-next page))
  326.           ; There. That wasn't hard, was it?
  327.           (setq size (read-disk-page page base-address))
  328.           (setf (gethash base-address hash) page))))
  329.     (when modify-p (mark-page-modified page))
  330.     (values (disk-page-data page)
  331.             offset
  332.             (- size offset)
  333.             page)))
  334.  
  335. (defun mark-page-modified (disk-page)
  336.   (unless (disk-page-dirty disk-page)
  337.     ; Link this disk-page as the last one in the dirty cache.
  338.     (let* ((disk-cache (disk-page-disk-cache disk-page))
  339.            (dirty-pages (disk-cache-dirty-pages disk-cache)))
  340.       (if dirty-pages
  341.         (let ((prev-dirty (disk-page-prev-dirty dirty-pages)))
  342.           (setf (disk-page-next-dirty prev-dirty) disk-page
  343.                 (disk-page-prev-dirty disk-page) prev-dirty
  344.                 (disk-page-next-dirty disk-page) dirty-pages
  345.                 (disk-page-prev-dirty dirty-pages) disk-page))
  346.         (setf (disk-page-next-dirty disk-page) disk-page
  347.               (disk-page-prev-dirty disk-page) disk-page
  348.               (disk-cache-dirty-pages disk-cache) disk-page)))
  349.     (setf (disk-page-dirty disk-page) t)))
  350.  
  351. ; Return the lock count after locking.
  352. (defun lock-page (disk-page)
  353.   (let ((lock-count (disk-page-lock-count disk-page)))
  354.     (declare (fixnum lock-count))
  355.     (when (eql 0 lock-count)
  356.       (let* ((disk-cache (disk-page-disk-cache disk-page))
  357.              (prev (disk-page-prev disk-page))
  358.              (next (disk-page-next disk-page))
  359.              (locked (disk-cache-locked-pages disk-cache))
  360.              (prev-locked (if locked (disk-page-prev locked) disk-page)))
  361.         (when (null locked)
  362.           (setf (disk-cache-locked-pages disk-cache) (setq locked disk-page)))
  363.         (setf (disk-page-next prev) next
  364.               (disk-page-prev next) prev
  365.               (disk-page-next prev-locked) disk-page
  366.               (disk-page-prev disk-page) prev-locked
  367.               (disk-page-prev locked) disk-page
  368.               (disk-page-next disk-page) locked)
  369.         (when (eq disk-page (disk-cache-pages disk-cache))
  370.           (setf (disk-cache-pages disk-cache)
  371.                 (if (eq next disk-page) nil next)))))
  372.     (setf (disk-page-lock-count disk-page)
  373.           (the fixnum (1+ lock-count)))))
  374.  
  375. ; Return the lock count or NIL if the page unlocked when this returns.
  376. (defun unlock-page (disk-page)
  377.   (let ((count (disk-page-lock-count disk-page)))
  378.     (declare (fixnum count))
  379.     (when (not (eql 0 count))
  380.       (progn
  381.         (when (eql count 1)
  382.           (let* ((disk-cache (disk-page-disk-cache disk-page))
  383.                  (prev-locked (disk-page-prev disk-page))
  384.                  (next-locked (disk-page-next disk-page))
  385.                  (pages (disk-cache-pages disk-cache))
  386.                  (prev (if pages (disk-page-prev pages) disk-page)))
  387.             (when (null pages)
  388.               (setf (disk-cache-pages disk-cache) (setq pages disk-page)))
  389.             (setf (disk-page-next prev-locked) next-locked
  390.                   (disk-page-prev next-locked) prev-locked
  391.                   (disk-page-next prev) disk-page
  392.                   (disk-page-prev disk-page) prev
  393.                   (disk-page-prev pages) disk-page
  394.                   (disk-page-next disk-page) pages)
  395.             (when (eq disk-page (disk-cache-locked-pages disk-cache))
  396.               (setf (disk-cache-locked-pages disk-cache)
  397.                     (if (eq next-locked disk-page) nil next-locked)))))
  398.         (setf (disk-page-lock-count disk-page) (decf count))
  399.         (and (not (eql 0 count)) count)))))
  400.  
  401.  
  402. (defmacro with-locked-page ((disk-page-or-disk-cache 
  403.                              &optional address modify-p array offset length page)
  404.                             &body body &environment env)
  405.   (if address
  406.     (let (ignored-params)
  407.       (multiple-value-bind (body-tail decls) (ccl::parse-body body env nil)
  408.         (flet ((normalize (param &optional (ignoreable? t))
  409.                  (or param
  410.                      (let ((res (gensym)))
  411.                        (if ignoreable? (push res ignored-params))
  412.                        res))))
  413.           `(multiple-value-bind (,(normalize array) ,(normalize offset)
  414.                                  ,(normalize length) ,(setq page (normalize page nil)))
  415.                                 (get-disk-page ,disk-page-or-disk-cache ,address
  416.                                                ,@(if modify-p `(,modify-p)))
  417.              ,@(when ignored-params
  418.                 `((declare (ignore ,@ignored-params))))
  419.              ,@decls
  420.              (with-locked-page (,page)
  421.                ,@body-tail)))))
  422.     (let ((page-var (gensym)))
  423.       `(let ((,page-var ,disk-page-or-disk-cache))
  424.          (unwind-protect
  425.            (progn
  426.              (lock-page ,page-var)
  427.              ,@body)
  428.            (unlock-page ,page-var))))))
  429.  
  430. (defun lock-page-at-address (disk-cache address)
  431.   (let ((page (nth-value 3 (get-disk-page disk-cache address))))
  432.     (values (lock-page page) page)))    
  433.  
  434. (defun extend-disk-cache (disk-cache new-size)
  435.   (let ((size (disk-cache-size disk-cache)))
  436.     (when (> new-size size)
  437.       ; Update size of last page
  438.       (let* ((page-address (logand (1- size) (disk-cache-mask disk-cache)))
  439.              (page (gethash page-address (disk-cache-page-hash disk-cache))))
  440.         (when page
  441.           (setf (disk-page-size page)
  442.                 (min (length (disk-page-data page)) (- new-size page-address)))))
  443.       ; Add some new pages, if not maxed out already
  444.       (let* ((page-size (disk-cache-page-size disk-cache))
  445.              (page-count (min (disk-cache-max-pages disk-cache)
  446.                               (floor (+ new-size page-size -1) page-size))))
  447.         (when (> (decf page-count (disk-cache-page-count disk-cache)) 0)
  448.           (add-disk-pages disk-cache page-count)))
  449.       ; increase the file size & install the new size
  450.       (setf (disk-cache-size disk-cache) new-size))))
  451.  
  452. (defun flush-all-disk-caches ()
  453.   (dolist (dc *open-disk-caches*)
  454.     (if (eq :closed (stream-direction (disk-cache-stream dc)))
  455.       (setq *open-disk-caches* (delq dc *open-disk-caches*))
  456.       (flush-disk-cache dc))))
  457.  
  458. (pushnew 'flush-all-disk-caches *lisp-cleanup-functions*)
  459.  
  460. #|
  461. (setq dc (open-disk-cache "temp.lisp"))
  462.  
  463. ; read a string from dc
  464. (defun rc (address size)
  465.   (declare (optimize (debug 3)))
  466.   (declare (special dc))
  467.   (let ((file-size (disk-cache-size dc)))
  468.     (setq size (max 0 (min size (- file-size address)))))
  469.   (let ((string (make-string size))
  470.         (index 0))
  471.     (loop
  472.       (when (<= size 0) (return string))
  473.       (multiple-value-bind (array array-index bytes) (get-disk-page dc address)
  474.         (dotimes (i (min size bytes))
  475.           (setf (schar string index) (code-char (aref array array-index)))
  476.           (incf index)
  477.           (incf array-index))
  478.         (decf size bytes)
  479.         (incf address bytes)))))
  480.  
  481. ; write a string to dc
  482. (defun wc (string address)
  483.   (declare (special dc))
  484.   (let* ((length (length string))
  485.          (min-size (+ address length))
  486.          (index 0))
  487.     (when (> min-size (disk-cache-size dc))
  488.       (extend-disk-cache dc min-size))
  489.     (loop
  490.       (when (<= length 0) (return))
  491.       (multiple-value-bind (array array-index bytes) (get-disk-page dc address t)
  492.         (dotimes (i (min length bytes))
  493.           (declare (type (array (unsigned-byte 8)) array))
  494.           (setf (aref array array-index) (char-code (schar string index)))
  495.           (incf index)
  496.           (incf array-index))
  497.         (incf address bytes)
  498.         (decf length bytes)))))
  499.  
  500. (close-disk-cache dc)
  501.  
  502. |#
  503.